Visual Basic Toolbox

home *** CD-ROM | disk | FTP | other *** search

/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / query / mquery / mgrid.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1994-05-24 | 18.4 KB | 626 lines

VERSION 2.00 Begin Form fGridFrm BackColor = &H00C0C0C0& ClientHeight = 3135 ClientLeft = 1455 ClientTop = 2640 ClientWidth = 6675 ClipControls = 0 'False Height = 3540 Icon = MGRID.FRX:0000 Left = 1395 LinkTopic = "Form1" ScaleHeight = 3125.913 ScaleMode = 0 'User ScaleWidth = 6692.959 Tag = "Dynaset" Top = 2295 Width = 6795 Begin Grid cGrid Height = 2715 Left = 0 TabIndex = 9 Top = 420 Width = 6675 End Begin PictureBox ViewButtons BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 375 Left = 0 ScaleHeight = 372 ScaleMode = 0 'User ScaleWidth = 5171.607 TabIndex = 0 Top = 24 Width = 5175 Begin CommandButton SortButton Caption = "&Sort" Height = 372 Left = 3720 TabIndex = 8 Top = 0 Width = 612 End Begin CommandButton FilterButton Caption = "Fil&ter" Height = 372 Left = 3120 TabIndex = 7 Top = 0 Width = 612 End Begin CommandButton RefreshButton Caption = "&Redo" Height = 372 Left = 2520 TabIndex = 6 Top = 0 Width = 612 End Begin CommandButton CloseButton Cancel = -1 'True Caption = "&Close" Height = 372 Left = 4320 TabIndex = 5 Top = 0 Width = 612 End Begin CommandButton MoreButton Caption = "&More" Height = 372 Left = 1320 TabIndex = 4 Top = 0 Width = 612 End Begin CommandButton NextButton Caption = "&Next" Height = 372 Left = 120 TabIndex = 3 Top = 0 Width = 612 End Begin CommandButton FirstButton Caption = "&First" Height = 372 Left = 720 TabIndex = 2 Top = 0 Width = 612 End Begin CommandButton FindButton Caption = "F&ind" Height = 372 Left = 1920 TabIndex = 1 Top = 0 Width = 612 End End Option Explicit 'form variables 'Dim FDS As dynaset 'current form's dynaset Dim FDS As snapshot 'current form's snapshot Dim FDynSt As String 'dynaset open string Dim FTblname As String 'form dynaset table name Dim FCurrentRow As Long 'current row in dynaset Dim FGridRow As Integer 'current grid row Dim FNotFound As Integer 'find not found flag Dim FFindForm As New fFind 'find form Dim FNumbRows As Long 'total number of rows in table Dim FDynaString As String 'dynaset open string Sub cGrid_DblClick () Dim r As Integer 'return from execute sql Dim fn As String 'field name On Error GoTo ZoomErr r = cGrid.Row cGrid.Row = 0 'get field name fn = cGrid.Text cGrid.Row = r 'make sure it's a string or memo field 'If FDS(fn).Type = FT_STRING Or FDS(fn).Type = FT_MEMO Then ' gstZoomData = cGrid.Text ' fZoom.Caption = fn ' fZoom.Top = Top + 1200 ' fZoom.Left = Left + 250 ' fZoom.CloseZoomButton.Visible = True 'fZoom.Show MODAL 'End If GoTo ZoomEnd ZoomErr: ShowError Resume ZoomEnd ZoomEnd: End Sub Sub cGrid_KeyUp (KeyCode As Integer, Shift As Integer) 'zoom on F4 key press If KeyCode = &H73 Then 'F4 cGrid_DblClick End If End Sub Sub CloseButton_Click () If Not gStoredFlag Then ' this query did not come from storage fQuery.RunSaveQryButton.Caption = "&Store Query " fQuery.RunSaveQryButton.Enabled = True fQuery.RunQueryButton.Enabled = False Else fQuery.RunSaveQryButton.Caption = "&Load Query" fQuery.RunSaveQryButton.Enabled = False fQuery.RunQueryButton.Enabled = False 'gStoredFlag = False End If fQuery.Show Unload Me End Sub Sub FilterButton_Click () On Error GoTo FilterErr ' Dim ds1 As dynaset, ds2 As dynaset Dim ds1 As snapshot, ds2 As snapshot 'Dim gFilterStr As String Dim numbrows As Long 'local number of rows Set ds1 = FDS 'save the dynaset Dim i As Integer, r As Integer, c As Integer 'On Error GoTo FindErr 'load the column names into the filter form 'the 1st time it is loaded fFilter.cExpr.Text = "" fFilter.cFieldList.Clear r = cGrid.Row c = cGrid.Col cGrid.Row = 0 cGrid.Col = 0 For i = 1 To cGrid.Cols - 1 cGrid.Col = cGrid.Col + 1 fFilter.cFieldList.AddItem cGrid.Text Next cGrid.Row = r cGrid.Col = c MsgBar "Enter Search Parameters without quotes", False fFilter.Show MODAL 'gFilterStr = InputBox("Enter Filter Expression:") If gFilterStr = "" Then Exit Sub FDS.Filter = gFilterStr ' Set ds2 = FDS.CreateDynaset() 'establish the filter Set ds2 = FDS.CreateSnapshot() 'establish the filter Set FDS = ds2 'assign back to original dynaset object 'everything must be okay so redisplay form on 1st record FNumbRows = GetNumbRecsSS(FDS) 'query numb of recs If FNumbRows = -1 Then 'error occurred but go on anyway 'because row count is non-critical Caption = "Dynaset: " + FTblname numbrows = gwMaxGridRows FCurrentRow = numbrows ElseIf FNumbRows = 0 Then Beep MsgBox "No Records found!", 48 ResetMouse Me Unload Me fQuery.Show Exit Sub ElseIf FNumbRows > gwMaxGridRows Then Caption = "Dynaset: " + FTblname + " [" + CStr(FNumbRows) + " total rows]" numbrows = gwMaxGridRows FCurrentRow = numbrows Else numbrows = FNumbRows Caption = "Dynaset: " + FTblname + " [" + CStr(FNumbRows) + " rows]" End If If LoadGrid(cGrid, FDS, FDynSt, numbrows, 0) = False Then Unload Me fQuery.Show Exit Sub End If GoTo FilterEnd FilterErr: ShowError Set FDS = ds1 're-assign back to original Resume FilterEnd FilterEnd: End Sub Sub FindButton_Click () Dim i As Integer, r As Integer, c As Integer On Error GoTo FindErr 'load the column names into the find form 'the 1st time it is loaded If FFindForm.cFieldList.ListCount = 0 Then FFindForm.cFieldList.Clear r = cGrid.Row c = cGrid.Col cGrid.Row = 0 cGrid.Col = 0 For i = 1 To cGrid.Cols - 1 cGrid.Col = cGrid.Col + 1 FFindForm.cFieldList.AddItem cGrid.Text Next cGrid.Row = r cGrid.Col = c End If FindStart: 'used to loop around on not found 'reset the flags gfFindFailed = False gfFromTableView = True MsgBar "Enter Search Parameters", False FFindForm.Show MODAL MsgBar "Searching for record", True If gfFindFailed = True Then Exit Sub FNotFound = False SetHourGlass Me 'search for the record cGrid.SetFocus 'start at the top SendKeys "^{Home}" cGrid.Col = 1 cGrid.Row = 0 'move the right column While cGrid.Text <> UCase(gstFindField) If cGrid.Col = cGrid.Cols Then 'reached max col Else cGrid.Col = cGrid.Col + 1 SendKeys "{Right}" End If Wend cGrid.Row = 1 While cGrid.Row < cGrid.Rows - 1 If gfFindMatch = False Then Select Case gstFindOp Case "=" If UCase(cGrid.Text) = UCase(gstFindExpr) Then GoTo AfterWhile Case "<>" If UCase(cGrid.Text) <> UCase(gstFindExpr) Then GoTo AfterWhile Case ">=" If UCase(cGrid.Text) >= UCase(gstFindExpr) Then GoTo AfterWhile Case "<=" If UCase(cGrid.Text) <= UCase(gstFindExpr) Then GoTo AfterWhile Case ">" If UCase(cGrid.Text) > UCase(gstFindExpr) Then GoTo AfterWhile Case "<" If UCase(cGrid.Text) < UCase(gstFindExpr) Then GoTo AfterWhile Case "Like" If UCase(cGrid.Text) Like UCase(gstFindExpr) Then GoTo AfterWhile End Select Else Select Case gstFindOp Case "=" If cGrid.Text = gstFindExpr Then GoTo AfterWhile Case "<>" If cGrid.Text <> gstFindExpr Then GoTo AfterWhile Case ">=" If cGrid.Text >= gstFindExpr Then GoTo AfterWhile Case "<=" If cGrid.Text <= gstFindExpr Then GoTo AfterWhile Case ">" If cGrid.Text > gstFindExpr Then GoTo AfterWhile Case "<" If cGrid.Text < gstFindExpr Then GoTo AfterWhile Case "Like" If cGrid.Text Like gstFindExpr Then GoTo AfterWhile End Select End If cGrid.Row = cGrid.Row + 1 SendKeys "{Down}" Wend FNotFound = True 'didn't find it AfterWhile: ResetMouse Me 'show the first record If FNotFound Then Beep MsgBox "Record Not Found", 48 GoTo FindStart End If DoEvents cGrid.SelStartRow = cGrid.Row cGrid.SelStartCol = 1 cGrid.SelEndRow = cGrid.Row cGrid.SelEndCol = FDS.Fields.Count GoTo FindEnd FindErr: ResetMouse Me ShowError Resume FindEnd FindEnd: MsgBar "", False End Sub Sub FirstButton_Click () Dim numbrows As Long 'number of rows On Error GoTo GoFirstError SetHourGlass Me MsgBar "Going to first record", True cGrid.SetFocus cGrid.Row = 1 cGrid.Col = 0 'get current starting row in grid If cGrid.Text <> "1" Then FDS.Close ' Set FDS = gCurrentDB.CreateDynaset(FDS.Name) Set FDS = gCurrentDB.CreateSnapshot(FDS.Name) FNumbRows = GetNumbRecsSS(FDS) If FNumbRows > gwMaxGridRows Then numbrows = gwMaxGridRows FCurrentRow = numbrows Else numbrows = FNumbRows End If If LoadGrid(cGrid, FDS, FDynSt, numbrows, 0) = False Then Unload Me fQuery.Show Exit Sub End If End If cGrid.Col = 1 SendKeys "{Home}" GoTo GoFirstEnd GoFirstError: ShowError Resume GoFirstEnd GoFirstEnd: ResetMouse Me MsgBar "", False End Sub Sub Form_Load () Dim t As TableDef 'local table structure Dim sp As Integer 'starting point of table name Dim ep As Integer 'ending point of table name Dim wh As String 'where clause Dim i As Integer, j As Integer Dim fn As String 'field name Dim rc As Integer 'record count Dim numbrows As Long 'local number of rows Dim ss As snapshot Dim ds As String gwMaxGridRows = 250 On Error GoTo DynasetErr SetHourGlass Me MsgBar "Opening Dynaset", True If gfFROMSQL = True Then ds = fQuery!cCriteria If gfFROMSQL Then gstDynaString = fQuery!cCriteria End If Else ds = gstDynaString End If 'attemp to open the dynaset Set FDS = gCurrentDB.CreateSnapshot(ds) 'parse off table name to store in global gstTblName wh = "" sp = InStr(1, UCase(ds), "FROM") If sp > 0 Then 'must be a "select from" statement sp = sp + 5 For ep = sp To Len(ds) 'search for a space or the end of ds If Mid$(ds, ep, 1) = " " Then 'get where clause if there is one wh = Mid$(ds, sp, Len(ds) - sp + 1) Exit For End If Next FTblname = UCase(Mid$(ds, sp, ep - sp)) If wh = "" Then wh = FTblname Else 'must be a table name only FTblname = UCase(ds) wh = FTblname End If gTblname = FTblname FDynaString = wh 'show the first record FNumbRows = GetNumbRecsSS(FDS) 'query numb of recs If FNumbRows = -1 Then 'error occurred but go on anyway 'because row count is non-critical Caption = "SnapShot: " + FTblname numbrows = gwMaxGridRows FCurrentRow = numbrows ElseIf FNumbRows = 0 Then Beep MsgBox "No Records found!", 48 ResetMouse Me Unload Me fQuery.Show Exit Sub ElseIf FNumbRows > gwMaxGridRows Then Caption = "SnapShot: " + FTblname + " [" + CStr(FNumbRows) + " total rows]" numbrows = gwMaxGridRows FCurrentRow = numbrows Else numbrows = FNumbRows Caption = "SnapShot: " + FTblname + " [" + CStr(FNumbRows) + " rows]" End If If LoadGrid(cGrid, FDS, ds, numbrows, 0) = False Then Unload Me fQuery.Show Exit Sub End If Height = 3800 + numbrows * 20 Width = 5450 + gsumcolwid / 2 'Left = 1000 'Top = 1000 Me.Left = (screen.Width - Me.Width) / 2 Me.Top = (screen.Height - Me.Height) / 2 Me.Show fQuery.Hide GoTo OkayEnd DynasetErr: ShowError ResetMouse Me MsgBar "", False Unload Me fQuery.Show Exit Sub Resume OkayEnd OkayEnd: ResetMouse Me MsgBar "", False End Sub Sub Form_Resize () On Error Resume Next 'resize grid to window If WindowState <> 1 Then 'not minimized cGrid.Height = Height - 900 cGrid.Width = Width - 100 End If End Sub Sub Form_Unload (Cancel As Integer) On Error Resume Next 'unload the find form Unload FFindForm 'close the associated dynaset FDS.Close MsgBar "", False End Sub Sub MoreButton_Click () Dim ret As Integer 'return value from loadgrid On Error Resume Next MsgBar "Getting more records", True If FDS.EOF <> True Then SetHourGlass Me ret = LoadGrid(cGrid, FDS, FDynSt, gwMaxGridRows, FCurrentRow) If ret = False Then 'failed so bail out of form FDS.Close Unload Me fQuery.Show End If 'set new current row FCurrentRow = FCurrentRow + ret ResetMouse Me Else MsgBox "All Records Loaded!", 48 End If MsgBar "", False End Sub Sub NextButton_Click () Dim c As Integer 'current column On Error GoTo GoNextError c = cGrid.Col cGrid.Col = 0 If cGrid.Text = "" Then Beep ElseIf cGrid.Row = gwMaxGridRows Then MoreButton_Click Else cGrid.SetFocus SendKeys "{Down}" End If cGrid.Col = c GoTo GoNextEnd GoNextError: ShowError Resume GoNextEnd GoNextEnd: End Sub 'needed for multi-user situations so 'new records can be viewed imediately Sub RefreshButton_Click () Dim numbrows As Long On Error GoTo RefreshError MsgBar "Reopening Dynaset", True SetHourGlass Me ' Set FDS = gCurrentDB.CreateDynaset(FDS.Name) Set FDS = gCurrentDB.CreateSnapshot(FDS.Name) FNumbRows = GetNumbRecsSS(FDS) If FNumbRows = -1 Then 'error occurred but go on anyway 'because row count is non-critical Caption = "Dynaset: " + FTblname numbrows = gwMaxGridRows FCurrentRow = numbrows ElseIf FNumbRows = 0 Then Beep MsgBox "No Records found!", 48 ResetMouse Me Unload Me fQuery.Show ElseIf FNumbRows > gwMaxGridRows Then Caption = "Dynaset: " + FTblname + " [" + CStr(FNumbRows) + " total rows]" numbrows = gwMaxGridRows FCurrentRow = numbrows Else numbrows = FNumbRows Caption = "Dynaset: " + FTblname + " [" + CStr(FNumbRows) + " rows]" End If If LoadGrid(cGrid, FDS, FDynSt, numbrows, 0) = False Then Unload Me fQuery.Show Exit Sub End If GoTo RefreshEnd RefreshError: ShowError Resume RefreshEnd RefreshEnd: ResetMouse Me MsgBar "", False End Sub Sub SortButton_Click () On Error GoTo SortErr ' Dim ds1 As dynaset, ds2 As dynaset Dim ds1 As snapshot, ds2 As snapshot 'Dim gSortStr As String Dim numbrows As Long 'local number of rows Set ds1 = FDS 'save the dynaset Dim i As Integer, r As Integer, c As Integer 'On Error GoTo FindErr 'load the column names into the filter form 'the 1st time it is loaded fSort.cFieldList.Clear r = cGrid.Row c = cGrid.Col cGrid.Row = 0 cGrid.Col = 0 For i = 1 To cGrid.Cols - 1 cGrid.Col = cGrid.Col + 1 fSort.cFieldList.AddItem cGrid.Text Next cGrid.Row = r cGrid.Col = c fSort.Show MODAL 'gSortStr = InputBox("Enter Sort Column:") If gSortStr = "" Then Exit Sub FDS.Sort = gSortStr ' Set ds2 = FDS.CreateDynaset() 'establish the Sort Set ds2 = FDS.CreateSnapshot() 'establish the Sort Set FDS = ds2 'assign back to original dynaset object 'everything must be okay so redisplay form on 1st record FNumbRows = GetNumbRecsSS(FDS) 'query numb of recs If FNumbRows = -1 Then 'error occurred but go on anyway 'because row count is non-critical Caption = "Dynaset: " + FTblname numbrows = gwMaxGridRows FCurrentRow = numbrows ElseIf FNumbRows = 0 Then Beep MsgBox "No Records found!", 48 ResetMouse Me Unload Me fQuery.Show Exit Sub ElseIf FNumbRows > gwMaxGridRows Then Caption = "Dynaset: " + FTblname + " [" + CStr(FNumbRows) + " total rows]" numbrows = gwMaxGridRows FCurrentRow = numbrows Else numbrows = FNumbRows Caption = "Dynaset: " + FTblname + " [" + CStr(FNumbRows) + " rows]" End If If LoadGrid(cGrid, FDS, FDynSt, numbrows, 0) = False Then Unload Me fQuery.Show Exit Sub End If GoTo SortEnd SortErr: ShowError Set FDS = ds1 're-assign back to original Resume SortEnd SortEnd: End Sub